home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / tcl / spectcl-.000 / spectcl- / usr / local / SpecTcl-0.1a / extract.tk < prev    next >
Encoding:
Text File  |  1995-11-06  |  4.9 KB  |  185 lines
  1. # SpecTcl, by S. A. Uhler
  2. # Copyright (c) 1994-1995 Sun Microsystems, Inc.
  3. #
  4. # See the file "license.txt" for information on usage and redistribution
  5. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  6. #
  7. # extract all the info about a widget into an array
  8. # - configuration options
  9. # - geometry options
  10. # - misc stuff
  11.  
  12. # {,i}pad[xy] and friends are problematic because both widgets and blt_table
  13. # use the same name.
  14.  
  15. proc widget_extract {widget {array ""}} {
  16.     global P
  17.     dputs $widget
  18.     if {$array == ""} {
  19.         set array [winfo name $widget]
  20.     }
  21.     global $array
  22.     upvar #0 $array data
  23.     # outline_inhibit 1
  24.  
  25.     # extract widget attributes
  26.     # don't extract command options if they already exist
  27.  
  28.     foreach option [$widget configure] {
  29.         if {[llength $option] == 5} {
  30.             set item [string trimleft [lindex $option 0] -]
  31.             if {![string match *command* $item] || ![info exists data($item)]} {
  32.                 set data($item) [lindex $option 4]
  33.             }
  34.         }
  35.     }
  36.  
  37.     # handle misc stuff
  38.  
  39.     foreach extra "tags master $P(other_items)" {
  40.         if {![info exists data($extra)]} {
  41.             set data($extra) {}
  42.         }
  43.     }
  44.     if {![info exists data(item_name)]} {
  45.         set data(item_name) [winfo name $widget]
  46.     }
  47.     set data(pathname) [winfo name $widget]
  48.     set data(type) [string tolower [winfo class $widget]]
  49.  
  50.     # extract geometry attributes (assume blt_table for now)
  51.     # need to handle row, col separately
  52.  
  53.     if {[winfo manager $widget] == "blt_table"} {
  54.         regsub -all { -([^ ]+)} [blt_table info $widget] { \1} options
  55.         regsub -all pad $options wad options    ;# botch for padding
  56.         regsub -all anchor $options align options    ;# botch for padding
  57.         array set $array [lrange $options 2 end]
  58.         regexp {([0-9]+),([0-9]+)} [lindex $options 1] x \
  59.                 data(row) data(column)
  60.     }
  61.  
  62.     # special (temporary) hack for frames
  63.  
  64.     if {$data(type) == "frame" && ![info exists data(panel)]} {
  65.         dputs "setting $widget panel to {}"
  66.         set data(panel) ""
  67.     }
  68.     # outline_inhibit 0
  69. }
  70.  
  71. # change a widget to reflect the current value of its array
  72. # validation should already be done
  73. # mangle the pathname as needed
  74.  
  75. proc widget_configure {array {root .can.f}} {
  76.     global Widget_data
  77.     upvar #0  $array data
  78.     dputs $array $root
  79.  
  80.     set widget $root.$data(pathname)
  81.     set class  $data(type)
  82.  
  83.     # extract the widget and geometry options
  84.  
  85.     set config "$class $widget"
  86.     set geom $data(row),$data(column)
  87.     foreach i [array names data] {
  88.         if {[info exists Widget_data(default:$class,$i)]} {
  89.             if {![string match *command* $i]} {
  90.                 append config " -$i [list $data($i)]"
  91.             }
  92.         } elseif {[info exists Widget_data(default:table,$i)]} {
  93.             append geom " -$i [list $data($i)]"
  94.         }
  95.     }
  96.  
  97.     # make the widget and manage it
  98.  
  99.     regsub -all {(-i?)wad([xy])} $geom {\1pad\2} geom    ;# padding botch
  100.     regsub -all align $geom anchor geom    ;# padding botch
  101.     dputs $config
  102.     eval $config
  103.     dputs "blt_table $data(master) $widget $geom"
  104.     eval "blt_table $root$data(master) $widget $geom"
  105.     return $widget
  106. }
  107.  
  108. # try to change a field option, return message on error
  109. #   name:  The name of the widget (e.g. [winfo name $window])
  110. #   item:  The option to be changed
  111. #   value: The value it wants to be set to
  112. #  return value:
  113. #   "":    validation suceeded, the widget value and associate array was changed
  114. #   <message>: Validation failed, reason is returned in result
  115.  
  116. proc validate_field {name item value} {
  117.     global Widget_data
  118.     upvar #0 $name data
  119.  
  120.     # run the output filter (if any) to do data conversion and (some) validation
  121.  
  122.     dputs "validating: $name $item $value"
  123.     if {[info exists Widget_data(outfilter:$item)]} {
  124.         dputs out-filtering $name: $item=<$value>
  125.         if {![$Widget_data(outfilter:$item) $name $item value]} {
  126.             return $value
  127.         }
  128.     }
  129.  
  130.     # set the widget value
  131.     # make sure to preserve any embedded "\n"'s in the value
  132.  
  133.     dputs $name
  134.     if {[string compare [info commands .$name] .$name] == 0} {
  135.         set widget .$name
  136.     } else {
  137.         set widget .can.f.$name
  138.     }
  139.     set class  $data(type)
  140.     set cmd ""
  141.     if {[string match *command* $item]} {
  142.         dputs skipping $item - its a command
  143.     } elseif {[info exists Widget_data(default:$class,$item)]} {
  144.         set cmd "$widget configure -$item \"[sub_bs $value 1]\""
  145.     } elseif {[info exists Widget_data(default:table,$item)]} {
  146.         set cmd [list blt_table configure $widget -$item $value]
  147.         regsub -all {(-i?)wad([xy])} $cmd {\1pad\2} cmd    ;# padding botch
  148.         regsub -all align $cmd anchor cmd    ;# padding botch
  149.     } elseif {[info exists Widget_data(default:position,$item)]} {
  150.         set base "blt_table .can.f$data(master) [blt_table info $widget]"
  151.         if {$item == "row"} {
  152.             set sub "$value,\\2"
  153.         } else {
  154.             set sub "\\1,$value"
  155.         }
  156.         regsub {([0-9]+),([0-9]+)} $base $sub cmd
  157.     } else {
  158.         dputs "unknown type: $item <- $value"
  159.         set data($item) $value
  160.     }
  161.  
  162.     # go set the value, and update the array
  163.     dputs "($item) $cmd"
  164.     set bad [catch "$cmd" msg]
  165.     if {$bad} {
  166.         return $msg
  167.     } else {
  168.         set data($item) $value
  169.         return ""
  170.     }
  171. }
  172.  
  173. # do '\n' substitutions on a string, but leave commands and variables alone
  174.  
  175. proc sub_bs {str {nosub 0}} {
  176.     regsub -all {([][$])} $str {\\\1} str
  177.     dputs $str
  178.     if {$nosub} {
  179.         return $str
  180.     } else {
  181.         return [subst $str]
  182.     }
  183. }
  184.  
  185.